home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d13 / oct90.arc / TIP590.LSP < prev    next >
Encoding:
Text File  |  1990-11-01  |  1.5 KB  |  48 lines
  1. ;TIP 590.LSP   Trim Short or Long Ends at an Intersection 
  2. ;(c)1990 Neil Devine
  3. (defun c:ctrim (/ A B P1 P2 S1 E1 E2 L1 L2)
  4.   (setvar "menuecho" 0)
  5.   (setq A (entsel "\nSelect end to eliminate: "))
  6.   (setq B (entsel "\n\n\nSelect end to eliminate: "))
  7.   (if (or (= nil A)(= nil B))
  8.     (princ "\n\nRoutine requires 2 intersecting lines...")
  9.     (progn ;else
  10.       (setq P1 (list (caadr A)(cadadr A)(caddar (cdr A)))
  11.             P2 (list (caadr B)(cadadr B)(caddar (cdr B)))
  12.             S1 (cdr (assoc 10 (setq L1 (entget (car A)))))
  13.             E1 (cdr (assoc 11 L1))
  14.             S2 (cdr (assoc 10 (setq L2 (entget (car B)))))
  15.             E2 (cdr (assoc 11 L2))
  16.             I (inters S1 E1 S2 E2 1)
  17.       )
  18.       (if (= nil I)
  19.         (princ "\n\nRoutine requires 2 intersecting lines...")
  20.         (progn  ;else
  21.           (if (< (distance S1 I)(distance S1 P1))
  22.             (progn
  23.               (setq L1 (subst (cons 11 I)(assoc 11 L1) L1))
  24.               (entmod L1)
  25.             )
  26.             (progn
  27.               (setq L1 (subst (cons 10 I)(assoc 10 L1) L1))
  28.               (entmod L1)
  29.             )
  30.           )
  31.           (if (< (distance S2 I)(distance S2 P2))
  32.             (progn
  33.               (setq L2 (subst (cons 11 I)(assoc 11 L2) L2))
  34.               (entmod L2)
  35.             )
  36.             (progn
  37.               (setq L2 (subst (cons 10 I)(assoc 10 L2) L2))
  38.               (entmod L2)
  39.             )
  40.           )
  41.         )
  42.       )
  43.     )
  44.   )
  45.   (princ)
  46. )
  47.  
  48.